home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Hack-Mag 3
/
Hack-Mag - Issue 3 (1991-02-02)(D-Tect)(PD).adf
/
Sources
/
TestThisFractalPRG.bas
< prev
Wrap
BASIC Source File
|
2014-06-19
|
10KB
|
440 lines
REM >->-> A P F E L M A E N C H E N <-<-<
REM
REM
Parameter:
INPUT "Zahl der Iterationen: ",Iter
INPUT "Zahl der Farben (2,4,8,16,32): ",Colors
DIM Betrag(Iter)
a=1
FOR S=1 TO Colors-1
PRINT S". Farb-Iter ";
INPUT b
FOR f=a TO b
Betrag(f)=S
NEXT f
a=b
NEXT S
PRINT
FOR S=1 TO Iter:PRINT Betrag(S):NEXT S
PRINT
IF Com=1 THEN GOTO CCont
INPUT "x-Start: ",xStart
INPUT "x-End: ",xEnd
INPUT "y-Start: ",yStart
INPUT "y-End: ",yEnd
PRINT
CCont:
INPUT "Screen-Breite: ",ScrWidth
INPUT "Screen-Höhe: ",ScrHight
Vorbereitungen:
IF Colors=2 THEN Tiefe=1
IF Colors=4 THEN Tiefe=2
IF Colors=8 THEN Tiefe=3
IF Colors=16 THEN Tiefe=4
IF Colors=32 THEN Tiefe=5
IF Com=1 THEN WINDOW 3:CLS:GOTO NoNew
SCREEN 2,320,256,5,1 '5!
WINDOW 3,,,0,2
NoNew:
PALETTE 0,0,0,0
PALETTE 1,0,0,1/16
PALETTE 2,0,0,2/16
PALETTE 3,0,0,3/16
PALETTE 4,0,0,4/16
PALETTE 5,0,0,5/16
PALETTE 6,0,0,6/16
PALETTE 7,0,0,7/16
PALETTE 8,0,0,8/16
PALETTE 9,0,0,9/16
PALETTE 10,0,0,10/16
PALETTE 11,0,0,11/16
PALETTE 12,0,0,12/16
PALETTE 13,0,0,13/16
PALETTE 14,0,0,14/16
PALETTE 15,0,0,15/16
x=0:y=0 'Variablen fuer Graphic
zr=0:zi=0 'Aufteilung der komplexen Zahl z
cr=xStart:ci=yStart 'Startkoordinaten der Apfel-Menge
xStep=((ABS(xStart)+ABS(xEnd))/ScrWidth)
yStep=((ABS(yStart)+ABS(yEnd))/ScrHight)
Kontrolle:
WINDOW 1
PRINT
PRINT "Iterationen: "Iter,"Farbzahl: "Colors
PRINT
PRINT "Beträge: ";
FOR S=1 TO Iter
PRINT Betrag(S);
NEXT S
PRINT
PRINT "xStart, xEnd, yStart, yEnd: "xStart" "xEnd" "yStart" "yEnd
PRINT "Breite, Breite: "ScrWidth" "ScrHight
PRINT "xStep, yStep: "xStep" "yStep
WHILE INKEY$="" : WEND
WINDOW 3
Berechnung:
WHILE y<ScrHight
FOR S=1 TO Iter
sr=zr*zr-zi*zi+cr
si=2*zi*zr+ci
r=sr*sr+si*si
IF r>=4 THEN loopExit
zr=sr
zi=si
NEXT S
loopExit:
zr=0:zi=0
x=x+1
IF x>ScrWidth THEN
y=y+1
x=1
cr=xStart
ci=ci-yStep
ELSE
cr=cr+xStep
END IF
IF r>=4 THEN PSET(x,y),Betrag(S)
WEND
Speichern:
WINDOW 1
INPUT "FileName: ",nam$
IF nam$="" THEN INPUT "FileName: ",nam$
IF nam$="" THEN sCont
WINDOW 3
GOSUB Main
sCont:
WHILE MOUSE(0)=0:WEND
WHILE MOUSE(0)=-1:WEND
BEEP
WINDOW 3
WHILE MOUSE(0)=0:WEND
x1=MOUSE(1):y1=MOUSE(2)
WHILE MOUSE(0)=-1:WEND
x2=MOUSE(1):y2=MOUSE(2)
xStart=xStart+x1*xStep
xEnd=xStart+x2*xStep
yStart=yStart-y1*yStep
yEnd=yStart-y2*yStep
Com=1
ERASE Betrag
WINDOW 1
GOTO Parameter
REM - SaveILBM
REM - von Carolyn Scheppner CBM 04/86
REM - Eindeutschung Ki 03.12.86
'" - ( s.a. Bitte-lesen, LoadACBM,
'" - LoadILBM-SaveACBM )
'" - Dieses Programm speichert einen
'" - eigenen Bildschirm (Screen),
'" - der eine Grafik enthält, als
'" - eine IFF-ILBM-Datei (lesbar von
'" - Graphicraft, Deluxe Paint, etc.).
'" - Die Datei erhält kein Piktogramm.
'" - Wenn Sie eins brauchen, kopieren
'" - Sie die .info-Datei eines
'" - Graphicraft-Bildes und benennen
'" - sie um zu IhreDatei.info .
'" - Daten fr zyklischen Farbwechsel
'" - werden als Graphicraft-CCRT-Chunk
'" - gespeichert. Sie können das Pro-
'" - gramm auch umbauen, so daß die
'" - Farbzyklus-Daten als CRNG-Chunk
'" - wie in dPaint gespeichert werden.
'" - (IFF-Dateien sind in benamte
'" - Abschnitte, Chunks, gegliedert.)
'" - Benötigt werden die .bmap-Dateien
'" - zu exec, graphics und dos .
Main:
DIM bPlane&(5), cTabSave%(32)
LIBRARY "dos.library"
LIBRARY "exec.library"
LIBRARY "graphics.library"
REM - Functionen aus dos.library
DECLARE FUNCTION xOpen& LIBRARY
DECLARE FUNCTION xRead& LIBRARY
DECLARE FUNCTION xWrite& LIBRARY
REM - xClose returns no value
REM - Functionen aus exec.library
DECLARE FUNCTION AllocMem&() LIBRARY
REM - FreeMem returns no value
ILBMname$=nam$
REM Eigener Screen, etwas Grafik
w = 320: h = 200: d = 5
AvailRam& = FRE(-1)
NeededRam& = ((w/8)*h*(d+1))+5000
IF AvailRam& < NeededRam& THEN
PRINT "Rechner-Speicherplatz reicht nicht aus."
GOTO Mcleanup2
END IF
t$=" SaveILBM"
REM - Screen-Structure-Adressen ermitteln
GOSUB GetScrAddrs
'" - Farbzyklusvariablen initialisieren
'" - ( mit 0 fr keinen Zyklus ).
'" - Diese Variablen mssen initialisiert
'" - werden, da diese Version von SaveILBM
'" - immer einen CCRT-Chunk wie fr
'" - Graphicraft abspeichert.
ccrtDir% = 0
ccrtStart% = 1
ccrtEnd% = nColors% - 1
ccrtSecs& = 0
ccrtMics& = 2000
REM - Screen als IFF-ILBM-Datei abspeichern
IF (ILBMname$<>"") THEN
saveError$ = ""
GOSUB SaveILBM
END IF
Mcleanup:
FOR de = 1 TO 5000:NEXT
Mcleanup2:
LIBRARY CLOSE
IF saveError$ <> "" THEN PRINT saveError$
RETURN
SaveILBM:
'" - Speichert aktuellen Fensterinhalt
'" - als IFF-ILBM-Datei mit einem
'" - CCRT-Farbzyklus-Chunk wie Graphicraft.
'" - (IFF-Dateien sind in benamte Chunks
'" - gegliedert.)
'" - Folgende Variablen mssen initiali-
'" - siert sein:
'" - ILBMname$ (IFF-ILBM-Dateiname)
'" - Und die Farbzyklus-Variablen:
'" - ccrtDir% (1,-1, oder 0 = kein Zyklus)
'" - ccrtStart% (niederwertiges Zyklus-Register)
'" - ccrtEnd% (höherwertiges Zyklus-Register)
'" - ccrtSecs& (Zykluszeit in Sekunden)
'" - ccrtMics& (Zykluszeit in Mikrosekunden)
'" - Variablen initialisieren
f$ = ILBMname$
fHandle& = 0
mybuf& = 0
filename$ = f$ + CHR$(0)
fHandle& = xOpen&(SADD(filename$),1006)
IF fHandle& = 0 THEN
saveError$ = "Ausgabedatei nicht erzeugbar."
GOTO Scleanup
END IF
REM - Pufferspeicherplatz reservieren
ClearPublic& = 65537&
mybufsize& = 120
mybuf& = AllocMem&(mybufsize&,ClearPublic&)
IF mybuf& = 0 THEN
saveError$ = "Pufferspeicher nicht verfgbar."
GOTO Scleanup
END IF
cbuf& = mybuf&
REM - Adressen der Screen-Structures ermitteln
GOSUB GetScrAddrs
zero& = 0
pad% = 0
aspect% = &HA0B
REM - Chunk-Längen berechnen
BMHDsize& = 20
CMAPsize& = (2^scrDepth%) * 3
CAMGsize& = 4
CCRTsize& = 14
BODYsize& = (ScrWidth%/8) * scrHeight% * scrDepth%
REM - FORMsize& = Chunk-Längen + 8 Bytes je Chunk-Header + "ILBM"
FORMsize& = BMHDsize&+CMAPsize&+CAMGsize&+CCRTsize&+BODYsize&+44
REM - FORM-Header schreiben
tt$ = "FORM"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(FORMsize&),4)
tt$ = "ILBM"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
IF wLen& <= 0 THEN
saveError$ = "Schreibfehler beim FORM-Header."
GOTO Scleanup
END IF
REM - BMHD-Chunk schreiben
tt$ = "BMHD"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(BMHDsize&),4)
wLen& = xWrite&(fHandle&,VARPTR(ScrWidth%),2)
wLen& = xWrite&(fHandle&,VARPTR(scrHeight%),2)
wLen& = xWrite&(fHandle&,VARPTR(zero&),4)
temp% = (256 * scrDepth%)
wLen& = xWrite&(fHandle&,VARPTR(temp%),2)
wLen& = xWrite&(fHandle&,VARPTR(zero&),4)
wLen& = xWrite&(fHandle&,VARPTR(aspect%),2)
wLen& = xWrite&(fHandle&,VARPTR(ScrWidth%),2)
wLen& = xWrite&(fHandle&,VARPTR(scrHeight%),2)
IF wLen& <= 0 THEN
saveError$ = "Schreibfehler beim BMHD-Chunk."
GOTO Scleanup
END IF
REM - CMAP-Chunk schreiben
tt$ = "CMAP"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(CMAPsize&),4)
REM - IFF-Farbpalette aufbauen
FOR kk = 0 TO nColors% - 1
regTemp% = PEEKW(colorTab& + (2*kk))
POKE(cbuf&+(kk*3)),(regTemp% AND &HF00) / 16
POKE(cbuf&+(kk*3)+1),(regTemp% AND &HF0)
POKE(cbuf&+(kk*3)+2),(regTemp% AND &HF) * 16
NEXT
wLen& = xWrite&(fHandle&,cbuf&,CMAPsize&)
IF wLen& <= 0 THEN
saveError$ = "Schreibfehler beim CMAP-Chunk."
GOTO Scleanup
END IF
REM - CAMG-Chunk schreiben
tt$ = "CAMG"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(CAMGsize&),4)
vpModes& = PEEKW(sViewPort& + 32)
wLen& = xWrite&(fHandle&,VARPTR(vpModes&),4)
IF wLen& <= 0 THEN
saveError$ = "Schreibfehler beim CAMG-Chunk"
GOTO Scleanup
END IF
REM - CCRT-Chunk schreiben
tt$ = "CCRT"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(CCRTsize&),4)
wLen& = xWrite&(fHandle&,VARPTR(ccrtDir%),2)
temp% = (256*ccrtStart%) + ccrtEnd%
wLen& = xWrite&(fHandle&,VARPTR(temp%),2)
wLen& = xWrite&(fHandle&,VARPTR(ccrtSecs&),4)
wLen& = xWrite&(fHandle&,VARPTR(ccrtMics&),4)
wLen& = xWrite&(fHandle&,VARPTR(pad%),2)
IF wLen& <= 0 THEN
saveError$ = "Schreibfehler beim CCRT-Chunk."
GOTO Scleanup
END IF
REM - BODY-Chunk schreiben (eigentliche Pixeldaten)
tt$ = "BODY"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(BODYsize&),4)
scrRowBytes% = ScrWidth% / 8
FOR rr = 0 TO scrHeight% -1
FOR pp = 0 TO scrDepth% -1
scrRow& = bPlane&(pp)+(rr*scrRowBytes%)
wLen& = xWrite&(fHandle&,scrRow&,scrRowBytes%)
IF wLen& <= 0 THEN
saveError$ = "Schreibfehler beim BODY-Chunk."
GOTO Scleanup
END IF
NEXT
NEXT
saveError$ = ""
Scleanup:
IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
RETURN
GetScrAddrs:
REM - Adressen der Screen-Structures ermitteln
sWindow& = WINDOW(7)
sScreen& = PEEKL(sWindow& + 46)
sViewPort& = sScreen& + 44
sRastPort& = sScreen& + 84
sColorMap& = PEEKL(sViewPort& + 4)
colorTab& = PEEKL(sColorMap& + 4)
sBitMap& = PEEKL(sRastPort& + 4)
REM - Screen-Parameter ermitteln
ScrWidth% = PEEKW(sScreen& + 12)
scrHeight% = PEEKW(sScreen& + 14)
scrDepth% = PEEK(sBitMap& + 5)
nColors% = 2^scrDepth%
REM - Adressen der Bit-Planes ermitteln
FOR kk = 0 TO scrDepth% - 1
bPlane&(kk) = PEEKL(sBitMap&+8+(kk*4))
NEXT
RETURN